home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / error.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-06-17  |  10.2 KB  |  447 lines
  1. /*    Copyright (C) 1995 Free Software Foundation, Inc.
  2.  * 
  3.  * This program is free software; you can redistribute it and/or modify
  4.  * it under the terms of the GNU General Public License as published by
  5.  * the Free Software Foundation; either version 2, or (at your option)
  6.  * any later version.
  7.  * 
  8.  * This program is distributed in the hope that it will be useful,
  9.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.  * GNU General Public License for more details.
  12.  * 
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with this software; see the file COPYING.  If not, write to
  15.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  *
  17.  * As a special exception, the Free Software Foundation gives permission
  18.  * for additional uses of the text contained in its release of GUILE.
  19.  *
  20.  * The exception is that, if you link the GUILE library with other files
  21.  * to produce an executable, this does not by itself cause the
  22.  * resulting executable to be covered by the GNU General Public License.
  23.  * Your use of that executable is in no way restricted on account of
  24.  * linking the GUILE library code into it.
  25.  *
  26.  * This exception does not however invalidate any other reasons why
  27.  * the executable file might be covered by the GNU General Public License.
  28.  *
  29.  * This exception applies only to the code released by the
  30.  * Free Software Foundation under the name GUILE.  If you copy
  31.  * code from other Free Software Foundation releases into a copy of
  32.  * GUILE, as the General Public License permits, the exception does
  33.  * not apply to the code that you add in this way.  To avoid misleading
  34.  * anyone as to the status of such modified files, you must delete
  35.  * this exception notice from them.
  36.  *
  37.  * If you write modifications of your own for GUILE, it is your choice
  38.  * whether to permit this exception to apply to your modifications.
  39.  * If you do not wish that, delete this exception notice.  
  40.  */
  41.  
  42.  
  43. #include <stdio.h>
  44. #include "_scm.h"
  45.  
  46.  
  47.  
  48.  
  49. /* {Errors and Exceptional Conditions}
  50.  */
  51.  
  52.  
  53. SCM scm_err_exp = SCM_UNDEFINED;
  54. SCM scm_err_env = SCM_UNDEFINED;
  55. char * scm_err_pos = "you lose (internal error)";
  56. char * scm_err_s_subr = "you lose (internal error)";
  57. scm_cell scm_tmp_errobj = {(SCM) SCM_UNDEFINED, (SCM) EOL};
  58. SCM *scm_loc_errobj = (SCM *) & scm_tmp_errobj;
  59. SCM system_error_sym;
  60.  
  61. struct errdesc scm_errmsgs[] =
  62. {
  63.   {"Wrong number of args", 0, 0},
  64.   {"numerical overflow", 0, FPE_SIGNAL},
  65.   {"Argument out of range", 0, FPE_SIGNAL},
  66.   {"Could not allocate", "out-of-storage", 0},
  67.   {"EXIT", "end-of-program", -1},
  68.   {"hang up", "hang-up", EXIT},
  69.   {"user interrupt", "user-interrupt", 0},
  70.   {"arithmetic error", "arithmetic-error", 0},
  71.   {"bus error", 0, 0},
  72.   {"segment violation", 0, 0},
  73.   {"alarm", "alarm-interrupt", 0}
  74. };
  75.  
  76. /* True only when errors indicate a bug in the
  77.  * interpreter.
  78.  */
  79. int scm_errjmp_bad = 1;
  80.  
  81. /* True between DEFER_INTS and ALLOW_INTS, and
  82.  * when the interpreter is not running at all.
  83.  */
  84. int scm_ints_disabled = 1;
  85.  
  86. /* Becomes true between DEFER_INTS and ALLOW_INTS if a
  87.  * a signal occurs.  Cleared by ALLOW_INTS which handles
  88.  * the signal.
  89.  */
  90. int scm_sig_deferred = 0;
  91.  
  92. /* Becomes true between DEFER_INTS and ALLOW_INTS if a
  93.  * an alarm signal occurs.  Cleared by ALLOW_INTS which handles
  94.  * the signal.
  95.  */
  96. int scm_alrm_deferred = 0;
  97.  
  98. /* Handle signal number I.
  99.  * If a scheme handler is allowed for this signal,
  100.  * and the user has defined one, call it and
  101.  * return i.
  102.  *
  103.  * Otherwise, if there is a more basic signal whose
  104.  * handler is applicable, return that signal number.
  105.  * 
  106.  * Otherwise return 0.
  107.  */
  108. #ifdef __STDC__
  109. static int 
  110. scm_handle_it (int i)
  111. #else
  112. static int 
  113. scm_handle_it (i)
  114.      int i;
  115. #endif
  116. {
  117.   char *name;
  118.   SCM proc;
  119.  
  120.   name = scm_errmsgs[i - WNA].s_response;
  121.   if (scm_errjmp_bad) return -1;
  122.   if (name)
  123.     {
  124.       NEWCELL(proc);        /* discard possibly-used cell */
  125.       proc = CDR (scm_intern (name, (sizet) strlen (name)));
  126.       if (NIMP (proc))
  127.     {
  128.       scm_apply (proc, EOL, EOL);
  129.       return i;
  130.     }
  131.     }
  132.   return scm_errmsgs[i - WNA].parent_err;
  133. }
  134.  
  135. #ifdef __STDC__
  136. void 
  137. scm_han_sig (void)
  138. #else
  139. void 
  140. scm_han_sig ()
  141. #endif
  142. {
  143.   scm_sig_deferred = 0;
  144.   if (INT_SIGNAL != scm_handle_it (INT_SIGNAL))
  145.     scm_wta (SCM_UNDEFINED, (char *) INT_SIGNAL, "");
  146. }
  147.  
  148. #ifdef __STDC__
  149. void 
  150. scm_han_alrm (void)
  151. #else
  152. void 
  153. scm_han_alrm ()
  154. #endif
  155. {
  156.   scm_alrm_deferred = 0;
  157.   if (ALRM_SIGNAL != scm_handle_it (ALRM_SIGNAL))
  158.     scm_wta (SCM_UNDEFINED, (char *) ALRM_SIGNAL, "");
  159. }
  160.  
  161. extern int errno;
  162. #ifdef __STDC__
  163. static void 
  164. err_head (char *str)
  165. #else
  166. static void 
  167. err_head (str)
  168.      char *str;
  169. #endif
  170. {
  171.   int oerrno = errno;
  172.   scm_exitval = MAKINUM (EXIT_FAILURE);
  173.   if (NIMP (cur_outp))
  174.     scm_fflush (cur_outp);
  175.   scm_putc ('\n', cur_errp);
  176.   if (BOOL_F != *scm_loc_loadpath)
  177.     {
  178.       scm_iprin1 (*scm_loc_loadpath, cur_errp, 1);
  179.       scm_puts (", line ", cur_errp);
  180.       scm_intprint ((long) scm_linum, 10, cur_errp);
  181.       scm_puts (": ", cur_errp);
  182.     }
  183.   scm_fflush (cur_errp);
  184.   errno = oerrno;
  185.   if (cur_errp == def_errp)
  186.     {
  187.       if (errno > 0)
  188.     perror (str);
  189.       fflush (stderr);
  190.       return;
  191.     }
  192. }
  193.  
  194. #ifdef __STDC__
  195. void 
  196. scm_warn (char *str1, char *str2)
  197. #else
  198. void 
  199. scm_warn (str1, str2)
  200.      char *str1;
  201.      char *str2;
  202. #endif
  203. {
  204.   err_head ("WARNING");
  205.   scm_puts ("WARNING: ", cur_errp);
  206.   scm_puts (str1, cur_errp);
  207.   scm_puts (str2, cur_errp);
  208.   scm_putc ('\n', cur_errp);
  209.   scm_fflush (cur_errp);
  210. }
  211.  
  212.  
  213. PROC (s_errno, "errno", 0, 1, 0, scm_errno);
  214. #ifdef __STDC__
  215. SCM 
  216. scm_errno (SCM arg)
  217. #else
  218. SCM 
  219. scm_errno (arg)
  220.      SCM arg;
  221. #endif
  222. {
  223.   int old = errno;
  224.   if (!UNBNDP (arg))
  225.     {
  226.       if (FALSEP (arg))
  227.     errno = 0;
  228.       else
  229.     errno = INUM (arg);
  230.     }
  231.   return MAKINUM (old);
  232. }
  233.  
  234. PROC (s_perror, "perror", 1, 0, 0, scm_perror);
  235. #ifdef __STDC__
  236. SCM 
  237. scm_perror (SCM arg)
  238. #else
  239. SCM 
  240. scm_perror (arg)
  241.      SCM arg;
  242. #endif
  243. {
  244.   ASSERT (NIMP (arg) && STRINGP (arg), arg, ARG1, s_perror);
  245.   err_head (CHARS (arg));
  246.   return UNSPECIFIED;
  247. }
  248.  
  249. #ifdef __STDC__
  250. void 
  251. def_err_response (void)
  252. #else
  253. void 
  254. def_err_response ()
  255. #endif
  256. {
  257.   SCM obj = *scm_loc_errobj;
  258.   DEFER_INTS;
  259.   err_head ("ERROR");
  260.   scm_puts ("ERROR: ", cur_errp);
  261.   if (scm_err_s_subr && *scm_err_s_subr)
  262.     {
  263.       scm_puts (scm_err_s_subr, cur_errp);
  264.       scm_puts (": ", cur_errp);
  265.     }
  266.   if (scm_err_pos == (char *) ARG1 && UNBNDP (*scm_loc_errobj))
  267.     scm_err_pos = (char *) WNA;
  268. #ifdef nosve
  269.   if ((~0x1fL) & (short) scm_err_pos)
  270.     scm_puts (scm_err_pos, cur_errp);
  271.   else if (WNA > (short) scm_err_pos)
  272.     {
  273.       scm_puts ("Wrong type in arg", cur_errp);
  274.       scm_putc('0'+(int)scm_err_pos, cur_errp);
  275.     }
  276. #else
  277.   if ((~0x1fL) & (long) scm_err_pos)
  278.     scm_puts (scm_err_pos, cur_errp);
  279.   else if (WNA > (long) scm_err_pos)
  280.     {
  281.       scm_puts ("Wrong type in arg", cur_errp);
  282.       scm_putc(scm_err_pos ? '0'+(int)scm_err_pos : ' ', cur_errp);
  283.     }
  284. #endif
  285.   else
  286.     {
  287.       scm_puts (scm_errmsgs[((int) scm_err_pos) - WNA].msg, cur_errp);
  288.       goto outobj;
  289.     }
  290.   if (IMP (obj) || SYMBOLP (obj) || (TYP16 (obj) == tc7_port)
  291.       || (NFALSEP (scm_procedure_p (obj))) || (NFALSEP (scm_number_p (obj))))
  292.     {
  293.     outobj:
  294.       if (!UNBNDP (obj))
  295.     {
  296.       scm_puts (((long) scm_err_pos == WNA) ? " to " : " ", cur_errp);
  297.       scm_iprin1 (obj, cur_errp, 1);
  298.     }
  299.     }
  300.   else
  301.     scm_puts (" (see errobj)", cur_errp);
  302.   if (UNBNDP (scm_err_exp))
  303.     goto getout;
  304.   if (NIMP (scm_err_exp))
  305.     {
  306.       scm_puts ("\n; in expression: ", cur_errp);
  307.       if (NCONSP (scm_err_exp))
  308.     scm_iprin1 (scm_err_exp, cur_errp, 1);
  309.       else if (SCM_UNDEFINED == CDR (scm_err_exp))
  310.     scm_iprin1 (CAR (scm_err_exp), cur_errp, 1);
  311.       else
  312.     scm_iprlist ("(... ", scm_err_exp, ')', cur_errp, 1);
  313.     }
  314.   if (NULLP (scm_err_env) || (BOOL_T == scm_procedure_p (CAR (scm_err_env))))
  315.     scm_puts ("\n; in top level environment.", cur_errp);
  316.   else
  317.     {
  318.       SCM env = scm_err_env;
  319.       scm_puts ("\n; in scope:", cur_errp);
  320.       while (NNULLP (env) && (BOOL_T != scm_procedure_p (CAR(env))))
  321.     {
  322.       scm_putc ('\n', cur_errp);
  323.       scm_puts (";   ", cur_errp);
  324.       scm_iprin1 (CAR (CAR (env)), cur_errp, 1);
  325.       env = CDR (env);
  326.     }
  327.     }
  328. getout:
  329.   scm_putc ('\n', cur_errp);
  330.   scm_fflush (cur_errp);
  331.   scm_err_exp = scm_err_env = SCM_UNDEFINED;
  332.   if (scm_errjmp_bad)
  333.     {
  334.       scm_iprin1 (obj, cur_errp, 1);
  335.       scm_puts ("\nFATAL ERROR DURING CRITICAL CODE SECTION\n", cur_errp);
  336. #ifdef vms
  337.       exit(EXIT_FAILURE);
  338. #else
  339.       exit(errno? (long)errno : EXIT_FAILURE);
  340. #endif
  341.     }
  342.   errno = 0;
  343.   ALLOW_INTS;
  344. }
  345.  
  346.  
  347.  
  348. #ifdef __STDC__
  349. void 
  350. scm_everr (SCM exp, SCM env, SCM arg, char *pos, char *s_subr)
  351. #else
  352. void 
  353. scm_everr (exp, env, arg, pos, s_subr)
  354.      SCM exp;
  355.      SCM env;
  356.      SCM arg; 
  357.      char *pos;
  358.      char *s_subr;
  359. #endif
  360. {
  361.  
  362.   /* Give preference to a user supplied error
  363.    * handler.
  364.    */
  365.   {
  366.     SCM desc;
  367.     SCM args;
  368.  
  369.     if ((~0x1fL) & (long) pos)
  370.       {
  371.     desc = makfrom0str (pos);
  372.       }
  373.     else
  374.       desc = MAKINUM ((long)pos);
  375.  
  376.     {
  377.       SCM sym;
  378.       if (!s_subr || !*s_subr)
  379.     sym = BOOL_F;
  380.       else
  381.     sym = CAR (scm_intern0 (s_subr));
  382.       args = scm_listify (desc, sym, arg, SCM_UNDEFINED);
  383.     }
  384.  
  385.     /* (throw (quote system-error) <desc> <proc-name> arg)
  386.      *
  387.      * <desc> is a string or an integer (see %%system-errors).
  388.      * <proc-name> is a symbol or #f in some annoying cases (e.g. cddr).
  389.      */
  390.  
  391.     _scm_throw (system_error_sym, args, 0);
  392.  
  393.     /* The call to throw might return if no handler can
  394.      * be found.
  395.      */
  396.   }
  397.   
  398.   /* Handle the error at the current root continuation. */
  399.   scm_err_exp = exp;
  400.   scm_err_env = env;
  401.   *scm_loc_errobj = arg;
  402.   scm_err_pos = pos;
  403.   scm_err_s_subr = s_subr;
  404.   if (   ((~0x1fL) & (long) pos)
  405.       || (WNA > (long) pos)
  406.       || NIMP(dynwinds)
  407.       || scm_errjmp_bad)
  408.     {
  409.       def_err_response ();
  410.       scm_abort ();
  411.     }
  412.   if (scm_errjmp_bad)
  413.     exit (INUM (scm_exitval));
  414.   scm_dowinds (EOL, scm_ilength (dynwinds));
  415.   longjmp (JMPBUF (rootcont), (int) pos);
  416.   /* Error processing is done at the stack base. */
  417. }
  418.  
  419. #ifdef __STDC__
  420. SCM
  421. scm_wta (SCM arg, char *pos, char *s_subr)
  422. #else
  423. SCM
  424. scm_wta (arg, pos, s_subr)
  425.      SCM arg;
  426.      char *pos;
  427.      char *s_subr;
  428. #endif
  429. {
  430.   scm_everr (SCM_UNDEFINED, EOL, arg, pos, s_subr);
  431.   return UNSPECIFIED;
  432. }
  433.  
  434.  
  435.  
  436. #ifdef __STDC__
  437. void
  438. scm_init_error (void)
  439. #else
  440. void
  441. scm_init_error ()
  442. #endif
  443. {
  444. #include "error.x"
  445. }
  446.  
  447.